home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / src / pt-fvc.cc < prev    next >
C/C++ Source or Header  |  1997-06-25  |  16KB  |  815 lines
  1. /*
  2.  
  3. Copyright (C) 1996 John W. Eaton
  4.  
  5. This file is part of Octave.
  6.  
  7. Octave is free software; you can redistribute it and/or modify it
  8. under the terms of the GNU General Public License as published by the
  9. Free Software Foundation; either version 2, or (at your option) any
  10. later version.
  11.  
  12. Octave is distributed in the hope that it will be useful, but WITHOUT
  13. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15. for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with Octave; see the file COPYING.  If not, write to the Free
  19. Software Foundation, 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  20.  
  21. */
  22.  
  23. #if defined (__GNUG__)
  24. #pragma implementation
  25. #endif
  26.  
  27. #ifdef HAVE_CONFIG_H
  28. #include <config.h>
  29. #endif
  30.  
  31. #include <iostream.h>
  32. #include <strstream.h>
  33.  
  34. #include <SLList.h>
  35.  
  36. #include "dynamic-ld.h"
  37. #include "error.h"
  38. #include "gripes.h"
  39. #include "oct-map.h"
  40. #include "oct-obj.h"
  41. #include "pager.h"
  42. #include "symtab.h"
  43. #include "pt-const.h"
  44. #include "pt-fvc.h"
  45. #include "pt-walk.h"
  46. #include "utils.h"
  47.  
  48. // But first, some extra functions used by the tree classes.
  49.  
  50. static bool
  51. any_element_less_than (const Matrix& a, double val)
  52. {
  53.   int nr = a.rows ();
  54.   int nc = a.columns ();
  55.  
  56.   for (int j = 0; j < nc; j++)
  57.     for (int i = 0; i < nr; i++)
  58.       if (a (i, j) < val)
  59.     return true;
  60.  
  61.   return false;
  62. }
  63.  
  64. static bool
  65. any_element_greater_than (const Matrix& a, double val)
  66. {
  67.   int nr = a.rows ();
  68.   int nc = a.columns ();
  69.  
  70.   for (int j = 0; j < nc; j++)
  71.     for (int i = 0; i < nr; i++)
  72.       if (a (i, j) > val)
  73.     return true;
  74.  
  75.   return false;
  76. }
  77.  
  78. // Make sure that all arguments have values.
  79.  
  80. // Are any of the arguments `:'?
  81.  
  82. static bool
  83. any_arg_is_magic_colon (const octave_value_list& args)
  84. {
  85.   int nargin = args.length ();
  86.  
  87.   for (int i = 0; i < nargin; i++)
  88.     if (args(i).is_magic_colon ())
  89.     return true;
  90.  
  91.   return false;
  92. }
  93.  
  94. // Symbols from the symbol table.
  95.  
  96. string
  97. tree_identifier::name (void) const
  98. {
  99.   string retval;
  100.   if (sym)
  101.     retval = sym->name ();
  102.   return retval;
  103. }
  104.  
  105. tree_identifier *
  106. tree_identifier::define (tree_constant *t)
  107. {
  108.   int status = sym->define (t);
  109.   return status ? this : 0;
  110. }
  111.  
  112. tree_identifier *
  113. tree_identifier::define (tree_function *t)
  114. {
  115.   int status = sym->define (t);
  116.   return status ? this : 0;
  117. }
  118.  
  119. void
  120. tree_identifier::document (const string& s)
  121. {
  122.   if (sym)
  123.     sym->document (s);
  124. }
  125.  
  126. octave_value
  127. tree_identifier::assign (const octave_value& rhs)
  128. {
  129.   octave_value retval;
  130.  
  131.   if (rhs.is_defined ())
  132.     {
  133.       if (! sym->is_defined ())
  134.     {
  135.       if (! (sym->is_formal_parameter ()
  136.          || sym->is_linked_to_global ()))
  137.         {
  138.           link_to_builtin_variable (sym);
  139.         }
  140.     }
  141.       else if (sym->is_function ())
  142.     {
  143.       sym->clear ();
  144.     }
  145.  
  146.       tree_constant *tmp = new tree_constant (rhs);
  147.  
  148.       if (sym->define (tmp))
  149.     retval = rhs;
  150.       else
  151.     delete tmp;
  152.     }
  153.  
  154.   return retval;
  155. }
  156.  
  157. octave_value
  158. tree_identifier::assign (const octave_value_list& args,
  159.              const octave_value& rhs)
  160. {
  161.   octave_value retval;
  162.  
  163.   if (rhs.is_defined ())
  164.     {
  165.       if (! sym->is_defined ())
  166.     {
  167.       if (! (sym->is_formal_parameter ()
  168.          || sym->is_linked_to_global ()))
  169.         {
  170.           link_to_builtin_variable (sym);
  171.         }
  172.     }
  173.       else if (sym->is_function ())
  174.     {
  175.       sym->clear ();
  176.     }
  177.  
  178.       if (sym->is_variable () && sym->is_defined ())
  179.     {
  180.       tree_constant *tmp = (tree_constant *) sym->def ();
  181.       retval = tmp->assign (args, rhs);
  182.     }
  183.       else
  184.     {
  185.       assert (! sym->is_defined ());
  186.  
  187.       if (! Vresize_on_range_error)
  188.         {
  189.           ::error ("indexed assignment to previously undefined variables");
  190.           ::error ("is only possible when resize_on_range_error is true");
  191.         }
  192.       else
  193.         {
  194.           tree_constant *tmp = new tree_constant ();
  195.           retval = tmp->assign (args, rhs);
  196.           if (retval.is_defined ())
  197.         sym->define (tmp);
  198.         }
  199.     }
  200.     }
  201.  
  202.   return retval;
  203. }
  204.  
  205. bool
  206. tree_identifier::is_defined (void)
  207. {
  208.   return (sym && sym->is_defined ());
  209. }
  210.  
  211. void
  212. tree_identifier::increment (void)
  213. {
  214.   if (sym)
  215.     {
  216.       if (sym->is_read_only ())
  217.     {
  218.       ::error ("can't redefined read-only variable `%s'",
  219.            name ().c_str ());
  220.     }
  221.       else
  222.     {
  223.       tree_fvc *tmp = sym->def ();
  224.       if (tmp)
  225.         tmp->increment ();
  226.     }
  227.     }
  228. }
  229.  
  230. void
  231. tree_identifier::decrement (void)
  232. {
  233.   if (sym)
  234.     {
  235.       if (sym->is_read_only ())
  236.     {
  237.       ::error ("can't redefined read-only variable `%s'",
  238.            name ().c_str ());
  239.     }
  240.       else
  241.     {
  242.       tree_fvc *tmp = sym->def ();
  243.       if (tmp)
  244.         tmp->decrement ();
  245.     }
  246.     }
  247. }
  248.  
  249. void
  250. tree_identifier::eval_undefined_error (void)
  251. {
  252.   int l = line ();
  253.   int c = column ();
  254.  
  255.   if (l == -1 && c == -1)
  256.     ::error ("`%s' undefined", name ().c_str ());
  257.   else
  258.     ::error ("`%s' undefined near line %d column %d",
  259.          name ().c_str (), l, c);
  260. }
  261.  
  262. // Try to find a definition for an identifier.  Here's how:
  263. //
  264. //   * If the identifier is already defined and is a function defined
  265. //     in an function file that has been modified since the last time 
  266. //     we parsed it, parse it again.
  267. //
  268. //   * If the identifier is not defined, try to find a builtin
  269. //     variable or an already compiled function with the same name.
  270. //
  271. //   * If the identifier is still undefined, try looking for an
  272. //     function file to parse.
  273. //
  274. //   * On systems that support dynamic linking, we prefer .oct files
  275. //     over .m files.
  276.  
  277. tree_fvc *
  278. tree_identifier::do_lookup (bool& script_file_executed, bool exec_script)
  279. {
  280.   script_file_executed = lookup (sym, exec_script);
  281.  
  282.   tree_fvc *retval = 0;
  283.  
  284.   if (! script_file_executed)
  285.     retval = sym->def ();
  286.  
  287.   return retval;
  288. }
  289.  
  290. void
  291. tree_identifier::link_to_global (void)
  292. {
  293.   if (sym)
  294.     link_to_global_variable (sym);
  295. }
  296.  
  297. void
  298. tree_identifier::mark_as_formal_parameter (void)
  299. {
  300.   if (sym)
  301.     sym->mark_as_formal_parameter ();
  302. }
  303.  
  304. octave_value
  305. tree_identifier::eval (bool print)
  306. {
  307.   octave_value retval;
  308.  
  309.   if (error_state)
  310.     return retval;
  311.  
  312.   bool script_file_executed = false;
  313.  
  314.   tree_fvc *object_to_eval = do_lookup (script_file_executed);
  315.  
  316.   if (! script_file_executed)
  317.     {
  318.       if (object_to_eval)
  319.     {
  320.       int nargout = maybe_do_ans_assign ? 0 : 1;
  321.  
  322.       if (nargout)
  323.         {
  324.           octave_value_list tmp_args;
  325.           octave_value_list tmp = object_to_eval->eval (0, nargout, tmp_args);
  326.  
  327.           if (tmp.length () > 0)
  328.         retval = tmp(0);
  329.         }
  330.       else
  331.         retval = object_to_eval->eval (false);
  332.     }
  333.       else
  334.     eval_undefined_error ();
  335.     }
  336.  
  337.   if (! error_state)
  338.     {
  339.       if (retval.is_defined ())
  340.     {
  341.       if (maybe_do_ans_assign && ! object_to_eval->is_constant ())
  342.         bind_ans (retval, print);
  343.       else if (print)
  344.         retval.print_with_name (name ());
  345.     }
  346.       else if (object_to_eval && object_to_eval->is_constant ())
  347.     eval_undefined_error ();
  348.     }
  349.  
  350.   return retval;
  351. }
  352.  
  353. octave_value_list
  354. tree_identifier::eval (bool print, int nargout, const octave_value_list& args)
  355. {
  356.   octave_value_list retval;
  357.  
  358.   if (error_state)
  359.     return retval;
  360.  
  361.   bool script_file_executed = false;
  362.  
  363.   tree_fvc *object_to_eval = do_lookup (script_file_executed);
  364.  
  365.   if (! script_file_executed)
  366.     {
  367.       if (object_to_eval)
  368.     {
  369.       if (maybe_do_ans_assign && nargout == 1)
  370.         {
  371.  
  372.           // Don't count the output arguments that we create
  373.           // automatically.
  374.  
  375.           nargout = 0;
  376.  
  377.           retval = object_to_eval->eval (0, nargout, args);
  378.  
  379.           if (retval.length () > 0 && retval(0).is_defined ())
  380.         bind_ans (retval(0), print);
  381.         }
  382.       else
  383.         retval = object_to_eval->eval (print, nargout, args);
  384.     }
  385.       else
  386.     eval_undefined_error ();
  387.     }
  388.  
  389.   return retval;
  390. }
  391.  
  392. void
  393. tree_identifier::accept (tree_walker& tw)
  394. {
  395.   tw.visit_identifier (*this);
  396. }
  397.  
  398. octave_value
  399. tree_identifier::value (void) const
  400. {
  401.   return sym->variable_value ();
  402. }
  403.  
  404. octave_value&
  405. tree_identifier::reference (void)
  406. {
  407.   return sym->variable_reference ();
  408. }
  409.  
  410. // Indirect references to values (structure elements).
  411.  
  412. tree_indirect_ref::~tree_indirect_ref (void)
  413. {
  414.   if (! preserve_ident)
  415.     delete id;
  416.  
  417.   if (! preserve_indir)
  418.     delete indir;
  419. }
  420.  
  421. string
  422. tree_indirect_ref::name (void) const
  423. {
  424.   string retval;
  425.  
  426.   if (is_identifier_only ())
  427.     retval = id->name ();
  428.   else
  429.     {
  430.       if (id)
  431.     retval = id->name ();
  432.       else if (indir)
  433.     retval = indir->name ();
  434.       else
  435.     panic_impossible ();
  436.  
  437.       retval.append (".");
  438.       retval.append (nm);
  439.     }
  440.     
  441.   return retval;
  442. }
  443.  
  444. octave_value
  445. tree_indirect_ref::eval (bool print)
  446. {
  447.   octave_value retval;
  448.  
  449.   if (is_identifier_only ())
  450.     retval = id->eval (print);
  451.   else
  452.     {
  453.       retval = value ();
  454.  
  455.       if (! error_state && retval.is_defined ())
  456.     {
  457.       if (maybe_do_ans_assign)
  458.         bind_ans (retval, print);
  459.       else if (print)
  460.         retval.print_with_name (name ());
  461.     }
  462.     }
  463.  
  464.   return retval;
  465. }
  466.  
  467. octave_value_list
  468. tree_indirect_ref::eval (bool print, int nargout,
  469.              const octave_value_list& args)
  470. {
  471.   octave_value_list retval;
  472.  
  473.   if (is_identifier_only ())
  474.     retval = id->eval (print, nargout, args);
  475.   else
  476.     {
  477.       octave_value tmp = value ();
  478.  
  479.       if (! error_state && tmp.is_defined ())
  480.     {
  481.       retval = tmp.index (args);
  482.  
  483.       if (! error_state)
  484.         {
  485.           if (maybe_do_ans_assign && nargout == 1
  486.           && retval.length () > 0 && retval(0).is_defined ())
  487.         bind_ans (retval(0), print);
  488.         }
  489.     }
  490.     }
  491.  
  492.   return retval;
  493. }
  494.  
  495. void
  496. tree_indirect_ref::accept (tree_walker& tw)
  497. {
  498.   tw.visit_indirect_ref (*this);
  499. }
  500.  
  501. octave_value
  502. tree_indirect_ref::value (void) const
  503. {
  504.   octave_value retval;
  505.  
  506.   if (is_identifier_only ())
  507.     retval = id->value ();
  508.   else
  509.     {
  510.       if (id)
  511.     retval = id->value ();
  512.       else if (indir)
  513.     retval = indir->value ();
  514.       else
  515.     panic_impossible ();
  516.  
  517.       if (! error_state)
  518.     retval = retval.struct_elt_val (nm);
  519.     }
  520.  
  521.   return retval;
  522. }
  523.  
  524. octave_value&
  525. tree_indirect_ref::reference (void)
  526. {
  527.   if (is_identifier_only ())
  528.     return id->reference ();
  529.   else
  530.     {
  531.       if (id)
  532.     {
  533.       octave_value& tmp = id->reference ();
  534.       if (tmp.is_undefined () || ! tmp.is_map ())
  535.         tmp = Octave_map ();
  536.       return tmp.struct_elt_ref (nm);
  537.     }
  538.       else if (indir)
  539.     {
  540.       octave_value& tmp = indir->reference ();
  541.       tmp.make_unique ();
  542.       if (tmp.is_undefined () || ! tmp.is_map ())
  543.         tmp = Octave_map ();
  544.       return tmp.struct_elt_ref (nm);
  545.     }
  546.       else
  547.     {
  548.       static octave_value foo;
  549.       panic_impossible ();
  550.       return foo;
  551.     }
  552.     }
  553. }
  554.  
  555. // Builtin functions.
  556.  
  557. tree_builtin::tree_builtin (const string& nm)
  558. {
  559.   is_mapper = 0;
  560.   fcn = 0;
  561.   my_name = nm;
  562. }
  563.  
  564. tree_builtin::tree_builtin (const builtin_mapper_function& m_fcn,
  565.                 const string &nm)
  566. {
  567.   mapper_fcn = m_fcn;
  568.   is_mapper = 1;
  569.   fcn = 0;
  570.   my_name = nm;
  571. }
  572.  
  573. tree_builtin::tree_builtin (Octave_builtin_fcn g_fcn, const string& nm)
  574. {
  575.   is_mapper = 0;
  576.   fcn = g_fcn;
  577.   my_name = nm;
  578. }
  579.  
  580. octave_value
  581. tree_builtin::eval (bool /* print */)
  582. {
  583.   octave_value retval;
  584.  
  585.   if (error_state)
  586.     return retval;
  587.  
  588.   if (fcn)
  589.     {
  590.       octave_value_list args;
  591.       octave_value_list tmp = (*fcn) (args, 0);
  592.       if (tmp.length () > 0)
  593.     retval = tmp(0);
  594.     }
  595.   else if (is_mapper)
  596.     {
  597.       ::error ("%s: too few arguments", my_name.c_str ());
  598.     }
  599.   else
  600.     panic_impossible ();
  601.  
  602.   return retval;
  603. }
  604.  
  605. static octave_value
  606. apply_mapper_fcn (const octave_value& arg, builtin_mapper_function& m_fcn,
  607.           bool /* print */)
  608. {
  609.   octave_value retval;
  610.  
  611.   if (m_fcn.ch_mapper)
  612.     {
  613.       // XXX FIXME XXX -- this could be done in a better way...
  614.  
  615.       octave_value tmp = arg.convert_to_str ();
  616.  
  617.       if (! error_state)
  618.     {
  619.       charMatrix chm = tmp.char_matrix_value ();
  620.  
  621.       if (! error_state)
  622.         {
  623.           int nr = chm.rows ();
  624.           int nc = chm.cols ();
  625.  
  626.           switch (m_fcn.flag)
  627.         {
  628.         case 0:
  629.           {
  630.             Matrix result (nr, nc);
  631.  
  632.             // islapha and friends can return any nonzero value
  633.             // to mean true, but we want to return 1 or 0 only.
  634.  
  635.             for (int j = 0; j < nc; j++)
  636.               for (int i = 0; i < nr; i++)
  637.             result (i, j)
  638.               = (*m_fcn.ch_mapper) (chm (i, j)) ? 1 : 0;
  639.  
  640.             retval = result;
  641.           }
  642.           break;
  643.  
  644.         case 1:
  645.           {
  646.             Matrix result (nr, nc);
  647.  
  648.             for (int j = 0; j < nc; j++)
  649.               for (int i = 0; i < nr; i++)
  650.             result (i, j)
  651.               = (*m_fcn.ch_mapper) (chm (i, j));
  652.  
  653.             retval = result;
  654.           }
  655.           break;
  656.  
  657.         case 2:
  658.           {
  659.             charMatrix result (nr, nc);
  660.  
  661.             for (int j = 0; j < nc; j++)
  662.               for (int i = 0; i < nr; i++)
  663.             result (i, j)
  664.               = (*m_fcn.ch_mapper) (chm (i, j));
  665.  
  666.             retval = octave_value (result, true);
  667.           }
  668.           break;
  669.  
  670.         default:
  671.           panic_impossible ();
  672.           break;
  673.         }
  674.         }
  675.     }
  676.     }
  677.   else
  678.     {
  679.       if (arg.is_real_type ())
  680.     {
  681.       if (arg.is_scalar_type ())
  682.         {
  683.           double d = arg.double_value ();
  684.  
  685.           if (m_fcn.flag
  686.           && (d < m_fcn.lower_limit || d > m_fcn.upper_limit))
  687.         {
  688.           if (m_fcn.c_c_mapper)
  689.             retval = m_fcn.c_c_mapper (Complex (d));
  690.           else
  691.             error ("%s: unable to handle real arguments",
  692.                m_fcn.name.c_str ());
  693.         }
  694.           else if (m_fcn.d_d_mapper)
  695.         retval = m_fcn.d_d_mapper (d);
  696.           else
  697.         error ("%s: unable to handle real arguments",
  698.                m_fcn.name.c_str ());
  699.         }
  700.       else
  701.         {
  702.           Matrix m = arg.matrix_value ();
  703.  
  704.           if (error_state)
  705.         return retval;
  706.  
  707.           if (m_fcn.flag
  708.           && (any_element_less_than (m, m_fcn.lower_limit)
  709.               || any_element_greater_than (m, m_fcn.upper_limit)))
  710.         {
  711.           if (m_fcn.c_c_mapper)
  712.             {
  713.               ComplexMatrix cm (m);
  714.               retval = cm.map (m_fcn.c_c_mapper);
  715.             }
  716.           else
  717.             error ("%s: unable to handle real arguments",
  718.                m_fcn.name.c_str ());
  719.         }
  720.           else if (m_fcn.d_d_mapper)
  721.         retval = m.map (m_fcn.d_d_mapper);
  722.           else
  723.         error ("%s: unable to handle real arguments",
  724.                m_fcn.name.c_str ());
  725.         }
  726.     }
  727.       else if (arg.is_complex_type ())
  728.     {
  729.       if (arg.is_scalar_type ())
  730.         {
  731.           Complex c = arg.complex_value ();
  732.  
  733.           if (m_fcn.d_c_mapper)
  734.         retval = m_fcn.d_c_mapper (c);
  735.           else if (m_fcn.c_c_mapper)
  736.         retval = m_fcn.c_c_mapper (c);
  737.           else
  738.         error ("%s: unable to handle complex arguments",
  739.                m_fcn.name.c_str ());
  740.         }
  741.       else
  742.         {
  743.           ComplexMatrix cm = arg.complex_matrix_value ();
  744.  
  745.           if (error_state)
  746.         return retval;
  747.  
  748.           if (m_fcn.d_c_mapper)
  749.         retval = cm.map (m_fcn.d_c_mapper);
  750.           else if (m_fcn.c_c_mapper)
  751.         retval = cm.map (m_fcn.c_c_mapper);
  752.           else
  753.         error ("%s: unable to handle complex arguments",
  754.                m_fcn.name.c_str ());
  755.         }
  756.     }
  757.       else
  758.     gripe_wrong_type_arg ("mapper", arg);
  759.     }
  760.  
  761.   return retval;
  762. }
  763.  
  764. octave_value_list
  765. tree_builtin::eval (bool /* print */, int nargout, const octave_value_list& args)
  766. {
  767.   octave_value_list retval;
  768.  
  769.   if (error_state)
  770.     return retval;
  771.  
  772.   int nargin = args.length ();
  773.  
  774.   if (fcn)
  775.     {
  776.       if (any_arg_is_magic_colon (args))
  777.     ::error ("invalid use of colon in function argument list");
  778.       else
  779.     retval = (*fcn) (args, nargout);
  780.     }
  781.   else if (is_mapper)
  782.     {
  783.       if (nargin > 1)
  784.     ::error ("%s: too many arguments", my_name.c_str ());
  785.       else if (nargin < 1)
  786.     ::error ("%s: too few arguments", my_name.c_str ());
  787.       else
  788.     {
  789.       if (args(0).is_defined ())
  790.         {
  791.           octave_value tmp = apply_mapper_fcn (args(0), mapper_fcn, 0);
  792.           retval(0) = tmp;
  793.         }
  794.       else
  795.         ::error ("%s: argument undefined", my_name.c_str ());
  796.     }
  797.     }
  798.   else
  799.     panic_impossible ();
  800.  
  801.   return retval;
  802. }
  803.  
  804. void
  805. tree_builtin::accept (tree_walker& tw)
  806. {
  807.   tw.visit_builtin (*this);
  808. }
  809.  
  810. /*
  811. ;;; Local Variables: ***
  812. ;;; mode: C++ ***
  813. ;;; End: ***
  814. */
  815.